home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / html_links.tcl.z / html_links.tcl
Text File  |  2002-07-08  |  16KB  |  620 lines
  1. # links.tcl
  2. # Suport for links and anchors
  3.  
  4. # Override HMlink_setup from the HTML library.
  5. # Mainly this is because we use the whole HTML tag to identify the
  6. # text range (not just L:$href).  We also improve the user feedback.
  7. # Note that the bindings on the "link" text tag are used to follow links.
  8.  
  9. proc HMlink_setup {win htag} {
  10.     upvar #0 HM$win var
  11.  
  12.     if {[info exists var(base)] && [HMextract_param $htag href] &&
  13.         [info exists href]} {
  14.     # Cut&Paste Hack
  15.     # Map from the inserted <base>+<link> to a relative link, if possible
  16.     set href_orig $href
  17.     set htag_orig $htag
  18.     UrlResolve $var(base) href
  19.     UrlRelative $var(S_url) href
  20.     regsub $href_orig $htag_orig $href htag
  21.     # This variable results in a text tag that represents the link
  22.     }
  23.     set var(T,a) [list H:$htag]    ;# Usually done by HMmark
  24.     set tag H:$htag
  25.  
  26.     HMextract_param $htag href
  27.     regsub -all % $href %% href2
  28.     $win tag configure $tag -foreground [Widget_ColorDefault $win c_link] -underline 1
  29.     $win tag bind $tag <Enter> \
  30.         [list HMlink_feedback $win hand2 $href2 $tag c_alink]
  31.     $win tag bind $tag <Leave> \
  32.         [list HMlink_feedback $win [option get $win cursor Text] "" $tag c_link]
  33.  
  34.     # Add to history so it shows up in URL chooser dialog
  35.     global History
  36.     if ![info exists History(href)] {
  37.     set History(href) $href        ;# Ought to be the title
  38.     }
  39. }
  40. proc HMlink_feedback {win cursor message tag colorName} {
  41.     upvar #0 Head$win head
  42.     $win config -cursor $cursor
  43.     Status $win $message
  44.  
  45.     if {[catch {$win tag configure $tag -foreground $head($colorName)}] &&
  46.         [catch {$win tag configure $tag -foreground #$head($colorName)}]} {
  47.     $win tag configure $tag -foreground blue
  48.     }
  49. }
  50. proc Url_AnchorColor {win varName} {
  51.     upvar #0 $varName colorize
  52.     if $colorize {
  53.     $win tag configure anchor -foreground purple
  54.     } else {
  55.     # Doesn't handle Body foreground text color right
  56.     $win tag configure anchor -foreground [$win cget -foreground]
  57.     }
  58. }
  59. proc UrlGetLink {win x y} {
  60.     set tags [$win tag names @$x,$y]
  61.     set ix [lsearch -glob $tags H:a*]
  62.     if {$ix < 0} {
  63.     return {}
  64.     }
  65.     regsub ^H: [lindex $tags $ix] {} htag
  66.     set href ""
  67.     HMextract_param $htag href
  68.     set target ""
  69.     HMextract_param $htag target
  70.     return [list $href $target]
  71. }
  72. # Url_Hit? is bound to <Button-1> on the link tag, which is shared by all links.
  73.  
  74. proc Url_Hit? {win x y} {
  75.     dputs Url_Hit? $x $y
  76.     if ![Input_Edit $win] {
  77.     Url_Hit $win $x $y
  78.     }
  79. }
  80. proc Url_Hit {win x y} {
  81.     dputs Url_Hit $x $y
  82.     lassign {href name} [UrlGetLink $win $x $y]
  83.     Html_HistoryAdd $win $href
  84.     Frame_Display $win $name $href
  85. }
  86. # This is like Url_Hit for regular hits, but it opens a new window.
  87. proc Url_HitNew {win x y} {
  88.     lassign {href target} [UrlGetLink $win $x $y]
  89.     Url_DisplayNew $href $win
  90. }
  91.  
  92. # Called from Double-Click
  93. proc Url_Edit {win x y} {
  94.     set tags [$win tag names @$x,$y]
  95.     set ix [lsearch -glob $tags H:a*]
  96.     if {$ix < 0} {
  97.     set htag {}
  98.     } else {
  99.     regsub ^H: [lindex $tags $ix] {} htag
  100.     }
  101.     UrlEditLink $win $htag [$win index @$x,$y]
  102. }
  103. # Called from Html Menu
  104. proc Url_EditLink {win} {
  105.     set tags [$win tag names insert]
  106.     set ix [lsearch -glob $tags H:a*]
  107.     if {$ix < 0} {
  108.     DialogInfo $win "You must first click on the link you want to edit."
  109.     return
  110.     }
  111.     Undo_Mark $win Url_EditLink
  112.     regsub ^H: [lindex $tags $ix] {} htag
  113.     UrlEditLink $win $htag insert
  114.     Undo_Mark $win Url_EditLinkEnd
  115. }
  116.  
  117. # Remote is called by exmh when we emulate "hippo" browser
  118. proc Remote {href interp} {
  119.     after 1 [list Url_DisplayNew $href]
  120. }
  121.  
  122. # Create a new window to display the href
  123. proc Url_DisplayNew {href {winorig {}}} {
  124.     if {$winorig != {}} {
  125.     upvar #0 HM$winorig varorig
  126.     set base $varorig(S_url)
  127.     Log $winorig Url_DisplayNew $href
  128.     }
  129.     set win [Window_New]
  130.     if [info exists base] {
  131.     upvar #0 HM$win var
  132.     set var(S_url) $base
  133.     }
  134.     Url_Display $win $href
  135.     return $win
  136. }
  137.  
  138. proc Url_Display {win href} {
  139.     if ![winfo exists $win] {
  140.     return
  141.     }
  142.     set win [Window_GetMaster $win]
  143.     set mode [Input_Edit $win]
  144.     Input_Mode $win 0
  145.     HMlink_callback $win $href
  146.     Input_Mode $win $mode
  147. }
  148.  
  149. proc Url_DisplayFrame {win href} {
  150.     set win0 [Window_GetMaster $win]
  151.     set mode [Input_Edit $win0]
  152.     Input_Mode $win 0
  153.     HMlink_callback $win $href
  154.     Input_Mode $win $mode
  155. }
  156.  
  157. # The following hook is called when a link is selected by the user
  158. proc HMlink_callback {win href {query ""}} {
  159.     global Busy
  160.     upvar #0 HM$win var
  161.     set base $var(S_url)
  162.  
  163.     if [Input_Edit $win] {
  164.     return    ;# Don't follow links in edit mode
  165.     }
  166.     if {[Input_IsDirty $win] && ![regexp ^# $href]} {
  167.     set x [DialogChoice [winfo toplevel $win] .dialog "Save Changes First?" \
  168.         [list Cancel "Save" "Save As..." "Do Not Save"] \
  169.         [list <Control-c> <Return> <Control-s> <Escape>]]
  170.     switch -- $x {
  171.         0 { return }
  172.         1 { File_Save $win }
  173.         2 { File_SaveAs $win }
  174.         3 { #do nothing }
  175.     }
  176.     }
  177.     Exmh_Debug base=$base href=$href query=$query
  178.     if ![info exists Busy($win)] {
  179.     set Busy($win) {}
  180.     }
  181.     catch {Http_kill $Busy($win)}
  182.     set Busy($win) {}
  183.  
  184.     if {[string length $base] && [string match #* $href]} {
  185.     # internal to this document
  186.     HMgoto $win [string trimleft $href #]
  187.     return
  188.     }
  189.  
  190.     # it's a out-of-page link
  191.  
  192.     if [catch {
  193.     set protocol [UrlResolve $base href]
  194.     Exmh_Debug resolved=$href protocol=$protocol
  195.     switch -regexp -- $protocol {
  196.         (http|ftp) {
  197.         regsub {#.*$} $href {} url
  198.         set Busy($win) $url
  199.         Status $win "Connecting to $url"
  200.         FeedbackLoop $win fetch
  201.         # For stop button
  202.         set var(S_urlPending) $url
  203.         if {$query != ""} {
  204.             dputs stderr "Query: $query"
  205.             Http_post $url $query [list UrlDisplay $win $url] \
  206.                       [list Url_Progress $win $href]
  207.         } else {
  208.             Http_get $url [list UrlDisplay $win $url] \
  209.                    [list Url_Progress $win $href]
  210.         }
  211.         }
  212.         file {
  213.         regsub {(file:(//?localhost)?)} $href {} file
  214.         regsub {#.*$} $file {} file
  215.         if [catch {UrlGetFile $file} html] {
  216.             Status $win "Error: $html"
  217.             set var(S_urlDisplay) $href
  218.         } else {
  219.             regsub {\?.*} $href {} url
  220.             set var(S_url) $url
  221.             Status $win "Displaying $var(S_url)"
  222.             Url_DisplayHtml $win $var(S_url) $html
  223.         }
  224.         }
  225.         mailto {
  226.         if {[string match exmh* [tk appname]]} {
  227.             Msg_Mailto $href
  228.         } else {
  229.             set interps [winfo interps]
  230.             set ix [lsearch -regexp $interps {exmh( #.)?$}]
  231.             if {$ix >= 0} {
  232.             set exmh [lindex $interps $ix]
  233.             Status $win "Using $exmh to send mail"
  234.             send $exmh [list Msg_Mailto $href]
  235.             } else {
  236.             regsub mailto: $href {} address
  237.             Status $win "Please send mail to $address"
  238.             }
  239.         }
  240.         }
  241.     }
  242.     } err] {
  243.     Status $win $err
  244.     set Busy($win) {}
  245.     }
  246. }
  247. proc Url_Progress { win href state current total} {
  248.     set parent [winfo parent $win]
  249.  
  250.     dputs $href $state $current $total
  251.  
  252.     if {"$parent" == "."} {set parent ""}
  253.     if {"$state" == "error"} {
  254.     Status $win $current
  255.     return
  256.     }
  257.     set bar $parent.status.msg.bar
  258.     if {$total > 0} {
  259.     set fract [expr double($current)/$total]
  260.     place $bar -relw $fract -height 2 -anchor sw -x 0 -rely 1.0
  261.     } else {
  262.     set fract 0
  263.     place $bar -relw 0.0 -height 2 -anchor sw -x 0 -rely 1.0
  264.     }
  265.     Status $win "$href $state [expr round(100.0*$fract)]%"
  266. }
  267.  
  268. proc Url_Validate {base href how callback} {
  269.     if {[string length $base] && [string match #* $href]} {
  270.     # internal to this document
  271.     return [list localanchor [string trimleft $href #]]
  272.     }
  273.     # it's a out-of-page link
  274.     set hreforig $href
  275.     set protocol [UrlResolve $base href]
  276.     switch -regexp -- $protocol {
  277.     http {
  278.         upvar #0 $href data
  279.         if {$how == "HEAD"} {
  280.         Http_head $href [list UrlValidateDone $href $callback]
  281.         } else {
  282.         # prefetch
  283.         Http_get $href [list UrlValidateDone $href $callback]
  284.         }
  285.     }
  286.     file {
  287.         regsub {(file:(//?localhost)?)} $href {} file
  288.         regsub {^/+} $file / file
  289.         set ok 1
  290.         if ![file exists $file] {
  291.         set ok 0
  292.         set status "no such file: $file"
  293.         }
  294.         if [file isdirectory $file] {
  295.         set status "$hreforig <code>directory</code>"
  296.         } else {
  297.         set status "$hreforig <code>file</code>"
  298.         }
  299.         eval $callback {$hreforig $ok $status}
  300.     }
  301.     ftp -
  302.     gopher -
  303.     wais -
  304.     mailto -
  305.     default {
  306.         eval $callback {$hreforig 1 $protocol}
  307.     }
  308.     }
  309. }
  310. proc UrlValidateDone {href callback} {
  311.     upvar #0 $href data
  312.     set ok 1
  313.     if ![info exists data] {
  314.     set ok 0
  315.     set result "$href killed"
  316.     } else {
  317.     set result $href
  318.     if [info exists data(type)] {
  319.         append result " <code>($data(type))</code>"
  320.     }
  321.     if ![string match 200* $data(http)] {
  322.         append result <br>$data(http)
  323.         switch -glob -- $data(http) {
  324.         30* {
  325.             set location ""
  326.             foreach {key value} $data(mime) {
  327.             if [regexp -nocase location $key] {
  328.                 set location $value
  329.             }
  330.             }
  331.             append result "<br>Redirect to: $location"
  332.             set ok 0
  333.         }
  334.         default {
  335.             set ok 0
  336.         }
  337.         }
  338.     }
  339.     }
  340.     if [catch {
  341.      eval $callback {$href $ok $result}
  342.     } err] {
  343.     Stderr "UrlValidateCallback: $err"
  344.     }
  345. }
  346. proc UrlValidateTimeout {href} {
  347.     upvar #0 $href data
  348.     if [info exists data] {
  349.     set data(valid) timeout
  350.     }
  351. }
  352. # Display a page.  We have to make sure we don't display one page while
  353. # still  displaying the previous one.  If we get here from a recursive 
  354. # invocation of the event loop, cancel whatever we were displaying when
  355. # we were called.
  356. # If we have a fragment name, try to go there.
  357.  
  358. proc UrlDisplay {win url} {
  359.     upvar #0 HM$win var
  360.     global Home
  361.     set fragment ""
  362.     regexp {([^#]*)#(.+)} $url dummy url fragment
  363.     upvar #0 $url data
  364.  
  365.     if {[info exists data(link)]} {
  366.     # Indirect link
  367.     Url_Display $win $data(link)
  368.     return
  369.     }
  370.  
  371.     Feedback $win ready
  372.     if {[scan $data(http) %d code] == 1} {
  373.     switch -glob -- $code {
  374.         2* { # ok }
  375.         4* { # Error document follows
  376.         DialogHtmlInfo $win "<code>$url</code><hr>$data(html)"
  377.         return
  378.         }
  379.         default {
  380.         DialogHtmlInfo $win "$url\n\n$data(http)"
  381.         return
  382.         }
  383.     }
  384.     }
  385.  
  386.     if {$url == "" && $fragment != ""} {
  387.     HMgoto $win $fragment
  388.     return
  389.     }
  390.     if {"$data(what)" == "error"} {
  391.     Status $win $data(message)
  392.     global Busy
  393.     set Busy($win) {}
  394.     HMset_state $win -stop 1    ;# stop displaying previous page if busy
  395.     return
  396.     }
  397.  
  398.     # was a link - switch to target
  399.  
  400.     Feedback $win busy
  401.     Status $win "Displaying $url"
  402.     if {$fragment != ""} {
  403.         HMgoto $win $fragment
  404.     }
  405.     if ![info exists data(type)] {
  406.     set data(type) {}
  407.     }
  408.  
  409.     # Call a content handler based on mime type
  410.     # E.g., Content_image/gif, then Content_image, then Content_default
  411.     foreach type [list $data(type) [Url_Parent $data(type)] default] {
  412.     if ![catch {Content_$type $win $url} stop] {
  413.         if {$stop} {
  414.         # Stop displaying previous page, if any
  415.             global Busy
  416.         set Busy($win) {}
  417.         Feedback $win ready
  418.         HMset_state $win -stop 1
  419.         Status $win ""
  420.         }
  421.         return
  422.     } else {
  423.         if ![string match "invalid command*" $stop] {
  424.         error "Content_$type failed" -errorInfo $errorInfo
  425.         }
  426.     }
  427.     }
  428. }
  429. proc Url_DisplayHtmlBegin {win url html} { 
  430.     Url_DisplayHtml $win $url $html "" 0
  431. }
  432. proc Url_DisplayHtml {win url html {saveundo ""} {setInsert 1}} {
  433.     upvar #0 HM$win var
  434.  
  435.     $win config -cursor watch -state normal
  436.     set var(S_urlDisplay) $url
  437.     catch {unset var(S_urlPending)}
  438.     wm iconname [winfo toplevel $win] [file tail $url]
  439.     if {$saveundo == ""} {
  440.     Undo_Reset $win            ;# Clear undo log
  441.     } else {
  442.     Undo_Mark $win Display        ;# This is part of refresh, save undo
  443.     }
  444.     HMreset_win $win $setInsert        ;# Set display state
  445.     Embed_Reset $win            ;# Nuke applets
  446.     Edit_Reset $win            ;# Set edit state
  447.     bindtags $win [list TScroll all]    ;# Disable input to the widget
  448.     Feedback $win busy
  449.     HMset_state $win -update 10        ;# Frequent updates during 1st display
  450.     set href [string first # $url]
  451.     if $href {
  452.     HMgoto $win [string range $url [expr {$href + 1}] end]
  453.     }
  454.     HMparse_html $html [list HMrender $win]
  455.     Input_Mode $win            ;# Restore edit or browse mode
  456.     HMset_state $win -update 1000    ;# Rare updates during editting
  457.     if {$setInsert} {
  458.     HMset_state $win -stop 1    ;# stop displaying previous page if busy
  459.     $win mark set insert 1.0
  460.     Input_Adjust $win            ;# In case we start with a  list
  461.     Mark_ReadTags $win insert        ;# Prime the display engine
  462.     Undo_Mark $win DisplayDone
  463.     }
  464.     if {$saveundo == ""} {
  465.     Undo_Init $win            ;# Reset the undo log
  466.     } else {
  467.     Undo_Mark $win DisplayDone
  468.     }
  469.     Toolbar_Update $win
  470.     Feedback $win ready
  471.     $win config -cursor xterm
  472. }
  473.  
  474. # given a file name, return its html, or invent some html if the file can't
  475. # be opened.
  476.  
  477. proc UrlGetFile {file} {
  478.     global Home
  479.     if [regexp ^http: $file] {
  480.     error "UrlGetFile $file"
  481.     }
  482.     regsub {^/+} $file / file
  483.     set fd [open $file]
  484.     set result [read $fd]
  485.     close $fd
  486.     return $result
  487. }
  488.  
  489. # resolve a SRC or HREF link into an absolute url
  490. # This side-effects the reference variable to do the conversion,
  491. # and it returns the protocol (.e.g, http, ftp, or file)
  492.  
  493. proc UrlResolve {base refVar} {
  494.     upvar $refVar ref
  495.     set ref [string trim $ref]
  496.     if {[regexp {^([^ :]+):(.+)} $ref x protocol rest]} {
  497.     if {[regexp -nocase (file|mail) $protocol] || [regexp ^// $rest]} {
  498.         return [string tolower $protocol]
  499.     }
  500.     regsub ^$protocol: $ref {} ref
  501.     }
  502.     # Original pattern: {([^:]+):(//[^/]*)(.*)}
  503.     if [regexp {^([^:]+):(/+[^/]*)(.*)$} $base dummy protocol server ext] {
  504.     set protocol [string tolower $protocol]
  505.     if {$protocol == "file"} {
  506.         set ext $server$ext
  507.         set server /
  508.     }
  509.     if [string match */ $ext] { 
  510.         set dir $ext
  511.     } else {
  512.         set dir [Url_Parent $ext]
  513.     }
  514.     if {$dir == "."} {set dir /}
  515.     while {[regsub {^\.\./} $ref {} ref] == 1} {
  516.         set dir [Url_Parent $dir]
  517.     }
  518.     if {[string match /* $ref]} {
  519.         set ref $protocol:$server$ref
  520.     } elseif {$dir == "/"} {
  521.         set ref $protocol:$server/$ref
  522.     } else {
  523.         set ref $protocol:$server/[string trim $dir /]/$ref
  524.     }
  525.     dputs $ref
  526.     return $protocol
  527.     }
  528.     if [regsub -nocase ^file: $base {} filebase] {
  529.     # dos names like file:c:, and file direname breaks with
  530.     # file:c:/, transforming that to file:c: no slash
  531.     set ref file:[file join [file dirname $filebase] [string trim $ref /]]
  532.     return file
  533.     }
  534.     set ref [Url_Parent $base]/[string trim $ref /]
  535.     if ![regexp {^([^:]+):} $ref x protocol] {
  536.     if [regexp {^www\.} $ref] {
  537.         set protocol http
  538.         set ref http://$ref
  539.     } else {
  540.         set protocol file
  541.         set ref file:$ref
  542.     }
  543.     }
  544.     dputs $ref
  545.     return [string tolower $protocol]
  546. }
  547.  
  548. # refVar points to an absolute URL.
  549. # This URL will be reduced to a URL relative to base.
  550.  
  551. proc UrlRelative {base refVar {absolute 1}} {
  552.     upvar $refVar ref
  553.     if [regexp -nocase ^mailto: $ref] {
  554.     return 0
  555.     }
  556.     if {[string length $base] == 0} {
  557.     return 0
  558.     }
  559.     if ![regexp {([^:]+):/+([^/]+)(.*)} $base dummy proto server ext] {
  560.     # Native file pathname URL
  561.     regexp {([^:]+):(.*)} $base dummy proto ext
  562.     set server {}
  563.     }
  564.     if ![regexp {([^:]+):/+([^/]+)(.*)} $ref dummy proto2 server2 ext2] {
  565.     regexp {([^:]+):(.*)} $base dummy proto2 ext2
  566.     set server2 {}
  567.     }
  568.     foreach var {proto proto2 server server2} {
  569.     set $var [string tolower [set $var]]
  570.     }
  571.     if {[string compare $server $server2] || [string compare $proto $proto2]} {
  572.     return 0
  573.     }
  574.     if ![string match */ $ext] {
  575.     set dir [Url_Parent $ext]        ;# Base directory to start at
  576.     } else {
  577.     set dir $ext
  578.     }
  579.     set prefix {}
  580.     while {! [string match $dir* $ext2]} {
  581.     set dir [Url_Parent $dir]
  582.     if {[string compare $dir "/"] == 0} {
  583.         if $absolute {
  584.         set ref $ext2        ;# No common parent directory
  585.         return 0
  586.         } else {
  587.         break
  588.         }
  589.     }
  590.     append prefix ../
  591.     }
  592.     regsub ^$dir $ext2 $prefix ext2
  593.     if !$absolute {
  594.     set ext2 [string trimleft $ext2 /]
  595.     }
  596.     set ref $ext2
  597.     return 1
  598. }
  599. proc Url_IsChild {base url} {
  600.     UrlResolve $base url
  601.     set url1 $url
  602.  
  603.     if {![UrlRelative $base url1]} {
  604.     return ""    ;# Not on the same server
  605.     }
  606.     # Worry about url1 as parent of project(base)
  607.     if [regexp {^\.\.} $url1] {
  608.     return ""
  609.     }
  610.     return $url        ;# Return absolute URL
  611. }
  612. # This is like "file dirname", but doesn't screw with the slashes
  613. #     file dirname http://www.sun.com/a
  614. #     => http:/www.sun.com
  615. proc Url_Parent {url} {
  616.     set url [string trimright $url /]
  617.     regsub {[^/]+$} $url {} url
  618.     return $url
  619. }
  620.